perm filename LINELN.F4[RST,LCS] blob sn#178138 filedate 1975-09-21 generic text, type T, neo UTF8
00100		SUBROUTINE LINELN
00110	
00120		DATA ZLINE/150.0/,HX/2./ 			
00130	
00200		COMMON/XRN/RN(2000) /SF/KL,RT,KP,STFSZ,NAMX
00300		COMMON RS,JA,CLEF,RA,RQ(16),K,N,J,JJ,KB,NA
00410		COMMON/STF/RSTFAC(-3/4),XLINE
00420		COMMON/POSI/STFF(-3/4),SIG,PQ/PTR/PWDS(250),L,LL,I,RX
00430		DIMENSION IV(78)
00500		EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
00600		1,(R8,RQ(6)),(R9,RQ(7)),(IV,PWDS)
00700		COMMON /PX/SX,PN(2000),Q(10000)
00710		I=L
00720		KK=1
00730		XLINE=ZLINE
00740		ENDLN=Q(IFIX(PN(L))+3)
00750		J=ENDLN/XLINE+.5
00760		TYPE 4,J
00770	4	FORMAT(I4,' LINES - OR TYPE NUM --',$)
00780		ACCEPT 5,RA
00790	5	FORMAT(F)
00792		IF(RA.NE.0)XLINE=ENDLN/RA
00795		RA=0
00800		CLEF=-99
00900		SIG=CLEF
01100	100	KL=1
01300		KP=1
01600		RT=2
01800		J=KK
01900		HGT=HX*3
02000		DO 1 K=KK,I
02100		N=PN(K)
02200		IF(Q(N+1).NE.4)GO TO 1
02300		IF(Q(N).GT.2)GO TO 1
02400		IF(Q(N+3).LT.XLINE)GO TO 1
02500	C  FOUND LAST BAR LINE.
02510		RX=0
02600	3	JJ=KP
02700	C PUTS IN STAFF
02800		CALL STAFF(8.,0,STFSZ)
02810		RN(KL-2)=HGT
02820		HGT=HGT-HX
02900		IF(KP.EQ.1.AND.KK.EQ.1)GO TO 33
03000		IF(CLEF.EQ.-99)GO TO 33
03100	C  ONLY STAFF FOR FIRST LINE AT TOP.
03200		RX=10*STFSZ
03300	C  THE SPACER
03500		CALL STAFF(3.,1.,CLEF)
03600		IF(SIG.EQ.-99)GO TO 33
03700		RX=12*STFSZ
03800	C  CLEF+SIG
04000		CALL STAFF(17.,11.0*STFSZ,SIG)
04100	
04200	33	R4=RA
04300		R5=Q(N+3)
04400		RS=3
04500		R7=RT
04600		R8=RX
04700		R9=200.
04800		LL=0
04900		L=I-J+1
05000		CALL PTMOVE(Q,PN(J))
05100		RA=R5
05200		KB=KL
05300		DO 30 NA=KK,K
05400		PWDS(KP)=KB
05500		KP=KP+1
05510		JK=PN(NA)
05520		R=Q(JK+1)
05530		IF(R.NE.5)GO TO 35
05540		IF(Q(JK+6).GT.201.)Q(JK+6)=201.
05550	C CATCHES END NF SLUR
05560		GO TO 30
05570	35	IF(R.NE.2)GO TO 36
05580		IF(Q(JK).LT.6.)GO TO 30
05590		RR=Q(IFIX(PN(NA-1))+3)
05600		Q(JK+3)=RR-1.6*STFSZ+(Q(IFIX(PN(NA+1))+3)-RR)/2.
05605	C CENTERS WHOLE REST
05607		GO TO 30
05610	36	IF(R.NE.3)GO TO 34
05619		RR=Q(JK+5)
05628		IF(Q(JK).LT.3)RR=0
05637		IF(RR.LE.3)CLEF=RR
05646		GO TO 30
05655	34	IF(R.NE.17)GO TO 30
05664		SIG=Q(JK+5)
05673		IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
05682	C  CLEF # IN P6 WITH KEY SIGS.
05691	30	KB=PN(NA+1)-PN(NA)+KB
05700	
05800		DO 31 NA=IFIX(PN(KK)),IFIX(PN(K+1)-1.)
05900		RN(KL)=Q(NA)
06000	31	KL=KL+1
06050		KK=K+1
06100		RS=RT
06200		LL='J'
06300		R4=0
06400		R5=200
06500		NA=L
06600		L=KP-JJ+1
06700		CALL PTMOVE(RN,PWDS(JJ))
06800		L=NA
06900		J=K+1
07000	C  SO IT DOESN'T GO THRU ALL DATA
07100		RT=RT-1
07200		XLINE=RA+ZLINE
07300		IF(K.EQ.I)GO TO 2
07310	10	IF(KL.GT.1700.OR.KP.GT.190.OR.RT)GO TO 2
07400	1	IF(K.EQ.I)GO TO 3
07600	2	L=KP
07610		PWDS(KP+1)=KB
07670		J=1
07718		CALL OFILE(1,NAMX)
07766		LL=PWDS(L+1)
07770	2929	WRITE(1),L,LL,
07780		1(PWDS(N),N=1,L+1),(RN(N),N=1,LL-1),J,J,J,J,RSTFAC,STFF,IV,STFF
07785		TYPE 101,NAMX
07787	101	FORMAT(1XA5)
07790		IF(KK.GE.I)CALL EXIT
07800		NAMX=NAMX+2
07810		END FILE(1)
07820		GO TO 100
07910		END
07920	
07930		SUBROUTINE STAFF(P1,P3,P5)
08000		COMMON/XRN/RN(2000) /SF/KL,RT,KP,STFSZ,NAMX
08100		COMMON /PTR/PWDS(250),L,LL,I,IX
08200		PWDS(KP)=KL
08210		KP=KP+1
08300		RN(KL)=3.
08400		RN(KL+1)=P1
08500		RN(KL+2)=RT
08600		RN(KL+3)=P3
08700		RN(KL+4)=0
08810		IF(P1.NE.17)GO TO 1
08820		IF(P5.LT.50)GO TO 1
08830		RN(KL)=4.
08835		R=IFIX((P5+50.)/100.)
08840		RN(KL+6)=R
08850		RN(KL+5)=P5-R*100.
08860		KL=KL+7
08870		RETURN
08880	1	RN(KL+5)=P5
08900		KL=KL+6
09000		END